home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / bbsutil / dlx70bbs.zip / DLX70SRC.ZIP / UTILS.PAS < prev    next >
Pascal/Delphi Source File  |  1994-02-28  |  34KB  |  1,186 lines
  1. {$debug-}
  2. {$line-}
  3.  
  4. {$include: 'types.int'}
  5. {$include: 'globals.int'}
  6. {$include: 'funs.int'}
  7. {$include: 'database.int'}
  8. {$include: 'load.int'}
  9. {$include: 'loadinit.int'}
  10. {$include: 'utils.int'}
  11.  
  12. IMPLEMENTATION OF utils;
  13.  
  14. {DLX Bulletin Board System V7.0
  15.  
  16.  FREEWARE NOTICE
  17.  
  18.  DLX V7.0 is placed in the public domain by its author, Richard Gillmann.
  19.  Anyone who wishes to may run the program, copy it, or modify it for
  20.  any purpose, including commercial gain.}
  21.  
  22. USES types,globals,funs,database,load,loadinit;
  23.  
  24. const
  25.   tab = chr(9);
  26.  
  27. var
  28.   screen_ptr [EXTERN] : screen_ads_typ;
  29.   wrap0 [EXTERN] : byte;
  30.  
  31. {***INTERFACE TO THE COM_PAX2 ASYNCHRONOUS COMMUNICATIONS PACKAGE***}
  32. {$include: 'com_pax2.int'}
  33.  
  34. {***Interface to the PASASM assembler utilities package***}
  35. {$include: 'pasasm.int'}
  36. {$include: 'newasm.int'}
  37.  
  38. {***Interface to KBD library***}
  39. {$include: 'kbd.int'}
  40.  
  41. {***Interface to MS Pascal library***}
  42. function getmqq(wants : word) : adsmem; EXTERN;
  43. procedure dismqq(block : adsmem); EXTERN;
  44. function umulok(a,b : word; var c : word) : boolean; EXTERN;
  45. procedure endxqq; EXTERN;
  46.  
  47. var
  48.   doseqq [EXTERN]: word;
  49.  
  50. procedure konkat{vars d : lstring; consts s : string};
  51. var
  52.   i,j : integer;
  53. begin
  54.   if ord(d.len)+UPPER(s) > UPPER(d) then
  55.     [j:=ord(d.len); d.len:=wrd(UPPER(d));
  56.      for i:=j+1 to UPPER(d) do d[i]:=s[i-j]]
  57.   else
  58.     concat(d,s);
  59. end {konkat};
  60.  
  61. procedure kopylst{consts s : string; vars d : lstring};
  62. begin
  63.   if UPPER(s) > UPPER(d) then
  64.     [d.len:=wrd(UPPER(d));
  65.      for var i:=1 to UPPER(d) do d[i]:=s[i]]
  66.   else
  67.     copylst(s,d);
  68. end {kopylst};
  69.  
  70. procedure kopystr{consts s : string; vars d : string};
  71. begin
  72.  if UPPER(s) > UPPER(d) then
  73.    for var i:=1 to UPPER(d) do d[i]:=s[i]
  74.  else
  75.    copystr(s,d);
  76. end {kopystr};
  77.  
  78. procedure load_em{vars w1,w2 : para};
  79. begin
  80.   write('1'); load_ss; load_mn;
  81.   fSmall:=true;
  82.   write('2'); load_macros;
  83.   write('3'); load_script;
  84.   fSmall:=false;
  85.   w1:=cwn_txt; w2:=wrn_txt;
  86. end {load_em};
  87.  
  88. function far_alloc{wants : word} {adsmem};
  89. begin
  90.   far_alloc:=getmqq(wants);
  91.   lhc:=lhc+wants+2;
  92.   if lhc>lhc_max then lhc_max:=lhc;
  93. end {far_alloc};
  94.  
  95. function newpara{consts s : string} {para};
  96. var
  97.   w : word;
  98.   p : para;
  99. begin
  100.   w:=para_size;
  101.   if fSmall then
  102.     [w:=w-wrd(screen_cols-UPPER(s));
  103.      if odd(w) then w:=w+1];
  104.   p:=far_alloc(w);
  105.   p^.amper:=false; p^.link:=nill; p^.crlfs:=0;
  106.   kopylst(s,p^.msg);
  107.   newpara:=p;
  108. end {newpara};
  109.  
  110. procedure dispara{p : adsmem};
  111. var
  112.   q : ads of word;
  113. begin
  114.   if p.s=0 then return;
  115.   q:=p; q.r:=q.r-2;
  116.   lhc:=lhc-q^-2;
  117.   dismqq(p);
  118. end {dispara};
  119.  
  120. procedure disparas{vars p : para};
  121. var
  122.   q : para;
  123. begin
  124.   while p<>nill do
  125.     [q:=p; p:=q^.link; dispara(q)];
  126. end {disparas};
  127.  
  128. procedure newhead{var h : mailhead};
  129. begin
  130.   new(h);
  131.   h^.head_link:=nil;
  132.   h^.text_first:=nill; h^.text_last:=nill;
  133.   h^.index:=0; h^.deleted:=false;
  134. end {newhead};
  135.  
  136. procedure dishead{h : mailhead};
  137. begin
  138.   if h<>nil then
  139.     [h^.text_first:=nill; h^.text_last:=nill;
  140.      h^.index:=0; h^.deleted:=false;
  141.      dispose(h)];
  142. end {dishead};
  143.  
  144. function date2jd{consts dd : string}  {integer4};
  145. var
  146.   c,ya : integer4;
  147.   month,day,year,temp : integer;
  148.   w : word;
  149. begin
  150. {get raw date}
  151.   month:=(ord(dd[1])-ord('0'))*10 + (ord(dd[2])-ord('0'));
  152.   day  :=(ord(dd[4])-ord('0'))*10 + (ord(dd[5])-ord('0'));
  153.   year :=(ord(dd[7])-ord('0'))*10 + (ord(dd[8])-ord('0'));
  154. {deal with non-American dates}
  155.   w := date_format;
  156.   if LOBYTE(w)>0 then [temp:=month; month:=day; day:=temp];
  157.   if LOBYTE(w)>1 then [temp:=year; year:=day; day:=temp];
  158. {process}
  159.   if year>=80
  160.     then year:=year+1900
  161.     else year:=year+2000;
  162.   if month > 2 then
  163.     month := month - 3
  164.   else begin
  165.     month := month + 9;  year := year - 1;
  166.   end {else};
  167.   c := year div 100;
  168.   ya := year mod 100;
  169.   date2jd := ((146097*c) div 4) + ((1461*ya) div 4) +
  170.              ((153*month + 2) div 5) + day + 1721119;
  171. end {date2jd};
  172.  
  173. function time2secs{const tt : string}  {integer4};
  174. var
  175.   secs : integer4;
  176. begin
  177.   if tt[1]>='0' and then tt[1]<='9' then
  178.     [secs:=(ord(tt[1])-ord('0'))*10 + (ord(tt[2])-ord('0'));
  179.      secs:=secs*60+((ord(tt[4])-ord('0'))*10 + (ord(tt[5])-ord('0')));
  180.      secs:=secs*60+((ord(tt[7])-ord('0'))*10 + (ord(tt[8])-ord('0')))]
  181.   else
  182.     secs:=0;
  183.   time2secs:=secs;
  184. end {time2secs};
  185.  
  186. function copy_of(p : para) : para;
  187. var
  188.   p1,p2 : para;
  189. begin
  190.   copy_of := nill;
  191.   p1:=nill;
  192.   while p<>nill do begin
  193.     p2:=newpara(p^.msg);
  194.     p2^.amper:=p^.amper; p2^.crlfs:=p^.crlfs;
  195.     if p1=nill
  196.       then copy_of:=p2
  197.       else p1^.link:=p2;
  198.     p1:=p2;
  199.     p:=p^.link;
  200.   end {while};
  201. end {copy_of};
  202.  
  203. procedure replace{vars big_s:lstring; consts little_s:lstring;
  204.                   pos,xlen : integer};
  205. {big_s is the string to be modified.  little_s is the new string
  206.  to be inserted into big_s at character position pos, replacing the
  207.  next xlen characters to be found there.}
  208. var
  209.   little_len,delta,freight,new_len : integer;
  210. begin
  211.   if pos<1 or else pos>ord(big_s.len) or else xlen<0 then return;
  212.   if xlen+pos-1 > ord(big_s.len) then xlen := ord(big_s.len)-pos+1;
  213.   little_len:=ord(little_s.len);
  214.   delta:=little_len-xlen;
  215.   if delta<>0 then begin
  216.     freight:=ord(big_s.len)-pos-xlen+1;
  217.     new_len:=ord(big_s.len)+delta;
  218.     if new_len>UPPER(big_s) then
  219.       [freight:=freight-(new_len-UPPER(big_s));
  220.        new_len:=UPPER(big_s)];
  221.     if delta>0 then big_s.len:=wrd(new_len);
  222.     if freight>0 then
  223.       [if delta>0 then {shift right}
  224.          movesr(ads big_s[pos+xlen],ads big_s[pos+little_len],wrd(freight))
  225.        else {shift left}
  226.          movesl(ads big_s[pos+xlen],ads big_s[pos+little_len],wrd(freight))];
  227.     if delta<0 then big_s.len:=wrd(new_len);
  228.   end {if};
  229.   if pos+little_len>UPPER(big_s) then
  230.     little_len:=UPPER(big_s)-pos+1;
  231.   if little_len>0 then
  232.     [if pos+little_len-1>ord(big_s.len) then big_s.len:=wrd(pos+little_len-1);
  233.      movesl(ads little_s[1],ads big_s[pos],wrd(little_len))];
  234. end {replace};
  235.  
  236. {evaluate if condition}
  237. {truth value of s[i1..i2-1] op s[i2..i3]}
  238. function tvalue(consts s : lstring; i1,i2,i3 : integer; op : char) : boolean;
  239. var
  240.   s0,s1,s2 : lstring(screen_cols div 2);
  241.   j,k : integer;
  242.   j4,k4 : integer4;
  243. begin
  244.   if i1=0 or else i3=0 then [tvalue:=false; return];
  245.   if i2=0 then {no operator}
  246.     [tvalue := (scanne(i3-i1+1,' ',s,i1) < i3-i1+1);
  247.      return];
  248.   s0.len := wrd(i2-i1+1);
  249.   if s0.len > UPPER(s0) then s0.len:=UPPER(s0);
  250.   if s0.len > 0 then movesl(ads s[i1],ads s0[1],s0.len);
  251.   stripx(s0,s1);
  252.   s0.len := wrd(i3-i2+1);
  253.   if s0.len > UPPER(s0) then s0.len:=UPPER(s0);
  254.   if s0.len > 0 then movesl(ads s[i2],ads s0[1],s0.len);
  255.   stripx(s0,s2);
  256.   if op=':' then
  257.     [for j:=1 to ord(s1.len) do s1[j]:=uc(s1[j]);
  258.      for j:=1 to ord(s2.len) do s2[j]:=uc(s2[j]);
  259.      tvalue := (positn(s2,s1,1) > 0)]
  260.   else if decode(s1,j4) and then decode(s2,k4) then
  261.     case op of
  262.       '<' : tvalue := (j4 < k4);
  263.       '=' : tvalue := (j4 = k4);
  264.       '#' : tvalue := (j4 <> k4);
  265.       '>' : tvalue := (j4 > k4);
  266.       otherwise tvalue:=false;
  267.     end {case}
  268.   else begin
  269.     if s1.len < s2.len then k:=ord(s1.len) else k:=ord(s2.len);
  270.     for j:=1 to k do
  271.       if uc(s1[j]) < uc(s2[j]) then
  272.         [tvalue := (op = '<'); return]
  273.       else if uc(s1[j]) > uc(s2[j]) then
  274.         [tvalue := (op = '>'); return];
  275.     case op of
  276.       '<' : tvalue := (s1.len < s2.len);
  277.       '=' : tvalue := (s1.len = s2.len);
  278.       '>' : tvalue := (s1.len > s2.len);
  279.     end {case};
  280.   end {else};
  281. end {tvalue};
  282.  
  283. {expand ampersand codes}
  284. function substitute{vars s : lstring} {boolean};
  285. var
  286.   i,j : integer;
  287.   str : lstring(screen_cols);
  288.   delta : integer;
  289.   c1,c2 : char;
  290.   if1,if2 : integer;
  291.   ifop : char;
  292.   skipmode : boolean;
  293. begin
  294.   substitute:=true;
  295.   if1:=0; if2:=0; ifop:=' '; skipmode:=false;
  296.   i:=1;
  297.   while i<=ord(s.len)-2 do begin
  298.     i:=i+scaneq(ord(s.len),'&',s,i);
  299.     if i>ord(s.len)-2 then break;
  300.     c1:=s[i+1]; c2:=uc(s[i+2]);
  301.     if c1='-' and then c2='-' then {comment}
  302.       [s.len:=wrd(i-1); br